home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / ksam.arc / KSAM.BAS next >
Encoding:
BASIC Source File  |  1980-01-01  |  8.4 KB  |  207 lines
  1. 1  '---------------------------------------------------------
  2. 2  '         SAMPLE PROGRAM USING KEYED ACCESS ROUTINES     -
  3. 3  ' --------------------------------------------------------
  4. 5  UA$="A"   ' .. DRIVE CONTAINING DATA
  5. 16 OPEN "R",#2,UA$+":DATA.EMP",84  ' .. OPEN DATA FILE
  6. 17 FIELD #2, 9 AS KY$, 20 AS NM$, 6 AS BD$, 1 AS SX$, 3 AS JC$, 20 AS A1$, 20 AS A2$, 5 AS ZP$
  7. 18 '
  8. 19 '    KY$ - ZIP CODE (KEY) JC$ - JOB CODE
  9. 20 '    NM$ - NAME           A1$ - STREET ADDR.
  10. 21 '    BD$ - BIRTH DATE     A2$ - CITY-STATE
  11. 22 '    SX$ - SEX            ZP$ - ZIP CODE
  12. 23 '
  13. 25 MX%=150: F1$="PTR.EMP"       ' ..INDEX FILE NAME
  14. 30 II%=1: GOSUB 2000            ' ..INITIALIZE DATA STRUCTURE
  15. 31 '
  16. 32 INPUT "OPERATION (D,A,L,S,LA,U,Q)";Q$
  17. 33 IF Q$="D" THEN GOSUB 150: GOTO 32         ' DELETE
  18. 34 IF Q$="L" THEN GOSUB 180: GOTO 32         ' LIST INDIVIDUAL DATA
  19. 35 IF Q$="A" THEN GOSUB 100: GOTO 32         ' ADD
  20. 36 IF Q$="S" THEN II%=8: GOSUB 2000: GOTO 32 ' DISPLAY STATISTICS
  21. 37 IF Q$="LA"THEN GOSUB 200: GOTO 32         ' LIST ALL RECORDS
  22. 38 IF Q$="U" THEN GOSUB 250: GOTO 32         ' UPDATE RECORD
  23. 40 IF Q$<>"Q" THEN 32
  24. 50 CLOSE: END
  25. 97  '
  26. 98  ' ***** ADD RECORD
  27. 99  '
  28. 100  INPUT "SS#";A$ : IF A$="END" THEN 120 ELSE IF LEN(A$)<>9 THEN 100
  29. 101  II%=5:GOSUB 2000: IF RC%<>0 THEN LSET KY$=A$: GOTO 102 ELSE PRINT"** ERROR - KEY ALREADY EXISTS": GOTO 100
  30. 102  INPUT "NAME";F$: LSET NM$=F$
  31. 105  INPUT "BIRTH DATE";F$: LSET BD$=F$
  32. 107  INPUT "SEX";F$: LSET SX$=F$
  33. 109  INPUT "JOB CODE";F$: LSET JC$=F$
  34. 110  INPUT "STREET";F$: LSET A1$=F$
  35. 111  INPUT "CITY-STATE";F$: LSET A2$=F$
  36. 112  INPUT "ZIP CODE";F$: LSET ZP$=F$
  37. 115  II%=2: GOSUB 2000      '.. ADD RECORD
  38. 116  IF RC%=0 THEN 100 ELSE PRINT"** ERROR - RECORD CANNOT BE STORED": GOTO 100
  39. 120  II%=7: GOSUB 2000      '.. STORE POINTERS
  40. 122  RETURN
  41. 147 '
  42. 148 ' ***** DELETE RECORD
  43. 149 '
  44. 150 ST%=0
  45. 151 INPUT "CODE TO DELETE";A$: IF A$="END" THEN 156
  46. 152 II%=4: GOSUB 2000
  47. 154 IF RC%=0 THEN ST%=1 ELSE  PRINT "** ERROR - KEY DOES NOT EXIST"
  48. 155 GOTO 151
  49. 156 IF ST%=1 THEN II%=7: GOSUB 2000   ' RESTORE POINTERS IF RECORD DELETED
  50. 158 RETURN
  51. 177 '
  52. 178 ' ***** LIST INDIVIDUAL RECORD
  53. 179 '
  54. 180 INPUT "SOCIAL SECURITY NUMBER";A$: IF A$="END" THEN 190
  55. 182 II%=5: GOSUB 2000: IF RC%<>0 THEN PRINT"**ERROR - KEY DOES NOT EXIST": GOTO 180
  56. 183 PRINT " "
  57. 184 PRINT "      NAME: ";NM$
  58. 185 PRINT "  JOB CODE: ";JC$
  59. 186 PRINT "BIRTH DATE: ";LEFT$(BD$,2);"/";MID$(BD$,3,2);"/";RIGHT$(BD$,2)
  60. 187 PRINT "   ADDRESS: ";A1$
  61. 188 PRINT TAB(13);A2$:PRINT ""
  62. 189 GOTO 180
  63. 190 RETURN
  64. 197 '
  65. 198 ' ***** LIST RANGE OF RECORDS
  66. 199 '
  67. 200 NX%=0: II%=6: K%=0
  68. 202 NX%=NX%+1: GOSUB 2000
  69. 204 IF RC%<>0 THEN 210
  70. 205 PRINT KY$,NM$
  71. 206 K%=K%+1: IF K%<10 THEN 202 ELSE INPUT ">";Q$  ' .. PAUSE
  72. 207 IF Q$<>"END" THEN K%=0: GOTO 202
  73. 210 RETURN
  74. 247 '
  75. 248 ' ***** UPDATE RECORD
  76. 249 '
  77. 250 INPUT "SS#";A$: IF A$="END" THEN 270
  78. 252 II%=5:GOSUB 2000    ' .. FETCH RECORD TO BE UPDATED
  79. 254 IF RC%=1 THEN PRINT "** ERROR - RECORD DOES NOT EXIST":GOTO 250
  80. 255 PRINT "NAME: /";NM$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET NM$=F$
  81. 257 PRINT "BIRTH DATE: /";BD$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET BD$=F$
  82. 258 PRINT "SEX: /";SX$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET SX$=F$
  83. 260 PRINT "JOB CODE: /";JC$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET JC$=F$
  84. 262 PRINT "STREET: /";A1$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET A1$=F$
  85. 263 PRINT "CITY-STATE: /";A2$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET A2$=F$
  86. 265 PRINT "ZIP CODE: /";ZP$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET ZP$=F$
  87. 266 II%=3: GOSUB 2000   ' .. RESTORE UPDATED RECORD
  88. 268 PRINT " ": GOTO 250
  89. 270 RETURN
  90. 1995 '
  91. 1996 ' -------------------------------------------------------------------
  92. 1997 ' -  FILE MANAGEMENT SUBROUTINES (II%,MX%,F1$,A$,PT%,PT$, NX%,RC%)  -
  93. 1998 ' -------------------------------------------------------------------
  94. 1999 '
  95. 2000 RC%=0: IF II%<1 OR II%>8 THEN RC%=1: RETURN
  96. 2001 IF II%=1 THEN 2006:  ' ELSE STORE VARIABLES USED BY SUBROUTINES
  97. 2004 ZZ%(1)=J%: ZZ%(2)=JJ%: ZZ%(3)=K%:ZZ%(4)=LO%: ZZ%(5)=HI%: ZZ%(6)=Z%
  98. 2005 '
  99. 2006 ON II% GOSUB 2035,2080,2090,2100,2150,2200,2250,2280
  100. 2007 '
  101. 2008 IF II%=1 THEN 2010:  ' ELSE RESTORE VARIABLES USED BY SUBROUTINES
  102. 2009 J%=ZZ%(1): JJ%=ZZ%(2): K%=ZZ%(3): LO%=ZZ%(4): HI%=ZZ%(5): Z%=ZZ%(6)
  103. 2010 RETURN
  104. 2034 REM --- (1) SUBROUTINE (MX%,F1$) --- INPUT POINTERS AND KEYS
  105. 2035 IF MX%<1 THEN RC%=1: RETURN
  106. 2037 MR%=(INT((MX%+2)/64)+1)*64
  107. 2038 DIM PT$(64),PT%(MR%),KE$(MX%),ZZ%(8)
  108. 2040 OPEN "R",#1,UA$+":"+F1$,128  ' INDEX FILE
  109. 2042 FOR J%=1 TO 64: FIELD #1,(J%-1)*2 AS DU$, 2 AS PT$(J%): NEXT J%
  110. 2050 K%=0: IF LOF(1)=0 THEN 2062
  111. 2051 FOR J%=1 TO INT(MR%/64)
  112. 2052 GET 1,J%  ' .. INPUT RECORD CONTAINING 64 POINTERS
  113. 2054 FOR JJ%=1 TO 64: K%=K%+1: PT%(K%)=CVI(PT$(JJ%)): NEXT JJ%
  114. 2055 NEXT J%
  115. 2056 '
  116. 2057 IF PT%(MR%)=0 THEN 2062
  117. 2058 FOR J%=1 TO PT%(MR%)+PT%(MR%-1)
  118. 2059 GET 2, J%: KE$(J%)=KY$
  119. 2060 NEXT J%
  120. 2062 RETURN
  121. 2079 REM --- (2) SUBROUTINE (MR%,A$, RC%) -- ADD RECORD TO FILE
  122. 2080 GOSUB 2500 : IF K%>0 THEN RC%=1: GOTO 2088
  123. 2083 GOSUB 2520 : IF Z%>MR%-1 THEN RC%=2: GOTO 2088
  124. 2085 K%=-K%:GOSUB 2540   ' .. INSERT POINTER . PT%(K%)=Z%
  125. 2086 KE$(Z%)=A$
  126. 2087 PUT 2,Z% ' .. STORE NEW RECORD
  127. 2088 RETURN
  128. 2089 REM -- (3) SUBROUTINE --- REWRITE RECORD
  129. 2090 GOSUB 2500: IF K%<0 THEN RC%=1: GOTO 2098
  130. 2092 PUT 2,PT%(K%)  ' .. STORE RECORD
  131. 2098 RETURN
  132. 2099 REM --- (4) SUBROUTINE (MR%,A$,RC%) --- DELETE A RECORD
  133. 2100 GOSUB 2500: IF K%<0 THEN RC%=1: GOTO 2110
  134. 2102 Z%=PT%(K%): IF K%=PT%(MR%) THEN 2107
  135. 2104 FOR J%=K% TO PT%(MR%)-1: PT%(J%)=PT%(J%+1): NEXT J%
  136. 2107 JJ%=PT%(MR%-1)
  137. 2108 PT%(PT%(MR%))=0: PT%(MR%)=PT%(MR%)-1: PT%(MR%-1)=JJ%+1:PT%(MR%-2-JJ%)=Z%
  138. 2110 RETURN
  139. 2149 REM --- (5) SUBROUTINE (MR%,A$,NX%,RC%) --- READ RECORD BY KEY
  140. 2150 GOSUB 2500: IF K%<0 THEN RC%=1: GOTO 2155
  141. 2152 GET 2,PT%(K%)    '.. INPUT RECORD
  142. 2153 NX%=K%
  143. 2155 RETURN
  144. 2199 REM --- (6) SUBROUTINE (MR%,NX%,RC%) --- READ RECORD BY SEQUENCE
  145. 2200 IF NX%<0 OR NX%>PT%(MR%) THEN RC%=1: GOTO 2205
  146. 2203 GET 2, PT%(NX%)
  147. 2205 RETURN
  148. 2249 REM --- (7) SUBROUTINE (MR%) --- RESTORE POINTERS
  149. 2250 K%=0: Z%=INT((PT%(MR%)-1)/64)+1
  150. 2252 FOR J%=1 TO Z%
  151. 2253 FOR JJ%=1 TO 64: K%=K%+1:LSET PT$(JJ%)=MKI$(PT%(K%)): NEXT JJ%: PUT 1,J%
  152. 2254 NEXT J%
  153. 2255 K%=INT(MR%/64): IF Z%=K% THEN 2259
  154. 2257 K%=(K%-1)*64: FOR J%=1 TO 64: LSET PT$(J%)=MKI$(PT%(J%+K%)):NEXT J%:PUT 1,INT(MR%/64)
  155. 2259 RETURN
  156. 2279 REM --- (8) SUBROUTINE -- DISPLAY FILE STATISTICS
  157. 2280 PRINT " ":IF PT%(MR%)=0 THEN PRINT "** NO RECORDS IN FILE": GOTO 2290
  158. 2282 PRINT "    ** FILE STATISTICS **": PRINT " "
  159. 2283 PRINT "  1. RECORDS IN FILE: ";PT%(MR%)
  160. 2284 PRINT "  2. DELETED RECORDS: ";PT%(MR%-1)
  161. 2285 PRINT "  3. LOWEST  KEY: ";KE$(PT%(1))
  162. 2286 PRINT "  4. HIGHEST KEY: ";KE$(PT%(PT%(MR%)))
  163. 2287 PRINT " "
  164. 2290 RETURN
  165. 2498 '
  166. 2499 REM --- SUBROUTINE (MR%,A$, K%) -- BINARY SEARCH
  167. 2500 IF PT%(MR%)=0 THEN K%=-1: RETURN
  168. 2502 LO%=0: HI%=PT%(MR%)+1
  169. 2504 M%=INT((LO%+HI%)/2)
  170. 2505 IF A$=KE$(PT%(M%)) THEN K%=M%: GOTO 2510
  171. 2506 IF A$>KE$(PT%(M%)) THEN LO%=M%: ELSE HI%=M%
  172. 2508 IF LO%+1 <> HI% THEN 2504 ELSE K%=-HI%
  173. 2510 RETURN
  174. 2518 '
  175. 2519 REM -- SUBROUTINE (MR%,PT%,Z%) -- LOCATE FREE RECORD IN DATA FILE
  176. 2520 IF PT%(MR%-1)=0 THEN Z%=PT%(MR%)+1: GOTO 2530
  177. 2522 J%=PT%(MR%):JJ%=PT%(MR%-1)
  178. 2524 Z%=PT%(MR%-1-JJ%): PT%(MR%-1)=PT%(MR%-1)-1: PT%(MR%-1-JJ%)=0
  179. 2530 RETURN
  180. 2538 '
  181. 2539 REM -- SUBROUTINE (MR%,K%,Z%) -- INSERT POINTER INTO POINTER VECTOR
  182. 2540 IF K%=PT%(MR%)+1 THEN 2548
  183. 2542 FOR J%=PT%(MR%)+1 TO K%+1 STEP -1
  184. 2544 PT%(J%)=PT%(J%-1)
  185. 2545 NEXT J%
  186. 2548 PT%(K%)=Z%: PT%(MR%)=PT%(MR%)+1
  187. 2550 RETURN
  188. 2997 ' --------------------------------------------------------------------
  189. 2998 ' -               PROGRAM TO INITIALIZE INDEX FILE                   -
  190. 2999 ' --------------------------------------------------------------------
  191. 3000 PRINT " ":PRINT TAB(5);"** INITIALIZE INDEX FILE **":PRINT " "
  192. 3001 INPUT "> DRIVE TO CONTAIN DATA";UA$
  193. 3002 INPUT "> FILE NAME";F$
  194. 3004 INPUT "> MAXIMUM NUMBER OF RECORDS FILE WILL HOLD";MX%
  195. 3006 MR%=(INT((MX%+2)/64)+1)*64
  196. 3008 DIM PT$(64)
  197. 3009 '--------------------------- OPEN FILE AND SET POINTERS TO 0
  198. 3010 OPEN "R",#1,UA$+":"+F$,128
  199. 3012 FOR J%=1 TO 64: FIELD #1,(J%-1)*2 AS DU$,2 AS PT$(J%):NEXT J%
  200. 3014 ZR$=MKI$(0): FOR J%=1 TO 64: LSET PT$(J%)=ZR$: NEXT J%
  201. 3015 '--------------------------- STORE BLOCKS OF ZERO POINTERS
  202. 3016 FOR J%=1 TO MR%/64
  203. 3018 PUT 1,J%
  204. 3020 NEXT J%
  205. 3022 PRINT " ": PRINT "   INITIALIZATION COMPLETE ON DRIVE";UA$
  206. 3025 END
  207.